home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / dbx.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  43.7 KB  |  1,810 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* interface to dbx for sem debugging */
  10. /* interface to dbx for sem debugging */
  11. #include "hdr.h"
  12. #include "libhdr.h"
  13. #include "vars.h"
  14. #include "ifile.h"
  15. #include "setprots.h"
  16. #include "arithprots.h"
  17. #include "sspansprots.h"
  18. #include "chapprots.h"
  19. #include "librprots.h"
  20. #include "miscprots.h"
  21. #include "smiscprots.h"
  22. #include "dbxprots.h"
  23.  
  24. #ifndef EXPORT
  25.  
  26. typedef struct explored
  27. {
  28.     short genre;    /* discriminant : is explored a node or a symbol ? */
  29.  
  30.     union {
  31.         Node   n;
  32.         Symbol s;
  33.     } addr;
  34. } explored;
  35.  
  36. #define UNDEFINED_STEP 99
  37. #define EXIT_STEP 100
  38. #define NODE_GENRE 0
  39. #define SYMBOL_GENRE 1
  40.  
  41.  
  42.  
  43. int zpadr_opt = 1;
  44. Symbol zsym;
  45. Set    zset;
  46. Node    znod;
  47. Declaredmap    zdcl;
  48. Tuple ztup;
  49. void give_node_reference(Node);
  50. void give_symbol_reference(Symbol);
  51. void zpnodrefa(char *, Node);
  52. void zpset(Set);
  53. void zpsig(Symbol);
  54. void zpsigt();
  55. void zptup(Tuple);
  56. void zpsetsym(Set);
  57. void zpsym(Symbol);
  58. void zpsymrefa(char *, Symbol);
  59. void zpsymref(Symbol);
  60. void zpnodref(Node);
  61. int analyze(char *, explored, int *, int *);
  62.  
  63. static int adrflag = 1; /* non zero to print address values */
  64. static int stack_ptr = 0;
  65. static explored stack[ 100 ];
  66. static void push(explored);
  67. static explored pop();
  68. static void display_symbol(Symbol);
  69. static void zpcon1(Const);
  70. static void zprat1(Rational);
  71.  
  72.  
  73. /*
  74.  * The purpose of this program is to provide the one who is not familiar
  75.  * with the structure of the AST with a tool which permits him to travel
  76.  * from one node to his eventual father or son (we assume that the
  77.  * beginning of the exploration will take place at the root of the AST .)
  78.  * and focus on the nodes he wants to examine more precisely in a readable
  79.  * way . 
  80.  */
  81.  
  82.  
  83. static void push (explored site)                /*;push*/
  84. {
  85.     stack [ stack_ptr++ ] = site;
  86. }
  87.  
  88. static explored pop ()                    /*;pop*/
  89. {
  90.     return (stack [ --stack_ptr ]);
  91. }
  92.  
  93. static void display_symbol(Symbol symbol_explored)        /*;display_symbol*/
  94. {
  95.     short nature;
  96.  
  97.     system ("clear");
  98.  
  99.     if (symbol_explored == (Symbol)0)
  100.         printf ("(Symbol)0\n");
  101.     else {
  102.         printf("NATURE %s        %d \n\n",
  103.           nature_str (NATURE (symbol_explored)), symbol_explored);
  104.         printf("NEEDNAME %d\n", NEEDNAME  (symbol_explored));
  105.         printf("TYPE_OF %s   %d\n",
  106.           nature_str(NATURE(TYPE_OF(symbol_explored))),
  107.           TYPE_OF(symbol_explored));
  108.         printf("ALIAS   %s   %d\n",
  109.           nature_str(NATURE(ALIAS(symbol_explored))), ALIAS(symbol_explored));
  110.         printf("SIGNATURE :\n");
  111.     
  112.         if (SIGNATURE (symbol_explored) != ((Tuple)0))
  113.             zptup(SIGNATURE (symbol_explored));
  114.         else
  115.             printf("empty_tuple\n");
  116.  
  117.         if (SCOPE_OF(symbol_explored))
  118.             printf("SCOPE_OF %s   %d\n",
  119.               nature_str(NATURE(SCOPE_OF(symbol_explored))),
  120.               SCOPE_OF(symbol_explored));
  121.         else
  122.             printf("No scope.\n");
  123.  
  124.         printf("OVERLOADS :\n");
  125.         if (OVERLOADS (symbol_explored) != ((Tuple)0)) {
  126.             nature = NATURE(symbol_explored);
  127.             if (nature == na_enum)
  128.                 printf(" literal map %d\n", OVERLOADS(symbol_explored));
  129.             else if (nature == na_package || nature == na_package_spec
  130.               || nature == na_generic_package_spec
  131.               || nature == na_generic_package || nature == na_task_type
  132.               || nature == na_task_obj)
  133.                 printf(" private declarations %d\n",
  134.                     OVERLOADS(symbol_explored));
  135.             else 
  136.                 display_symbol_list  (OVERLOADS (symbol_explored), 1);
  137.         }
  138.         else
  139.             printf ("empty_set\n");
  140.         printf("DECLARED %d\n", DECLARED (symbol_explored));
  141.         if (ORIG_NAME (symbol_explored) != (char *)0)
  142.             printf("ORIG_NAME %s\n", ORIG_NAME (symbol_explored));
  143.         printf("SEQ %d\n", S_SEQ (symbol_explored));
  144.         printf("UNIT %d\n", S_UNIT (symbol_explored));
  145.         printf("TYPE_ATTR %d\n", TYPE_ATTR (symbol_explored));
  146.         if (MISC (symbol_explored) != (char *)0)
  147.             printf("MISC %s\n", MISC (symbol_explored));
  148.         printf("TYPE_KIND %d\n", TYPE_KIND (symbol_explored));
  149.         printf("TYPE_SIZE %d\n", TYPE_SIZE (symbol_explored));
  150.  
  151.         if (INIT_PROC(symbol_explored))
  152.             printf("INIT_PROC %s   %d\n",
  153.               nature_str(NATURE(INIT_PROC(symbol_explored))),
  154.               INIT_PROC(symbol_explored));
  155.         else printf("INIT_PROC = 0\n");
  156.  
  157.         printf("ASSOCIATED_SYMBOLS :\n");
  158.         if (ASSOCIATED_SYMBOLS (symbol_explored) != ((Tuple)0))
  159.             display_symbol_list (ASSOCIATED_SYMBOLS (symbol_explored), 1);
  160.         else
  161.             printf ("empty_tuple\n");
  162.         printf("SEGMENT %d\n", S_SEGMENT (symbol_explored));
  163.         printf("OFFSET %d\n", S_OFFSET (symbol_explored));
  164.         printf("\n");
  165.     }
  166. }
  167.  
  168. void display_node(Node node_explored, int list_begin)    /*;display_node*/
  169. {
  170.     int kind_explored;
  171.  
  172.     system ("clear");
  173.  
  174.     if (node_explored == (Node)0)
  175.         printf ("(Node)0\n");
  176.     else {
  177.         kind_explored = N_KIND (node_explored);
  178.  
  179.         printf ("kind -> %s  ", kind_str (kind_explored));
  180.         printf ("unit -> %d  ", N_UNIT (node_explored));
  181.         printf ("side -> %d  ", N_SIDE (node_explored));
  182.         printf ("overloaded -> %d  ", N_OVERLOADED (node_explored));
  183.         printf ("sequence -> %d ", N_SEQ (node_explored));
  184.         printf ("\n");
  185.         printf ("%d", kind_explored);
  186.  
  187.         printf ("\n");
  188.         printf ("\n");
  189.  
  190.         /*****************/
  191.         /* nu1 component */
  192.         /*****************/
  193.         printf (" nu1 :  ");
  194.  
  195.         if (N_AST1_DEFINED (kind_explored)) {
  196.             if (N_AST1(node_explored) != (Node)0)
  197.                 printf ("AST1 %s \n", kind_str(N_KIND(N_AST1(node_explored))));
  198.             else
  199.                 printf ("AST1 (Node)0 \n");
  200.         }
  201.         else 
  202.             printf ("SPAN %d %d \n", N_SPAN0 (node_explored),
  203.               N_SPAN1 (node_explored));
  204.  
  205.         printf ("\n");
  206.  
  207.         /*****************/
  208.         /* nu2 component */
  209.         /*****************/
  210.         printf (" nu2 :  ");
  211.  
  212.         if (N_AST2_DEFINED (kind_explored)) {
  213.             if (N_AST2(node_explored) != (Node)0)
  214.                 printf ("AST2 %s \n",
  215.                     kind_str(N_KIND(N_AST2(node_explored))));
  216.             else
  217.                 printf ("AST2 (Node)0 \n");
  218.         }
  219.         else if (N_LIST_DEFINED (kind_explored)) {
  220.             printf ("LIST ");
  221.             if (N_LIST (node_explored) != ((Tuple)0))
  222.                 display_node_list (N_LIST (node_explored), list_begin);
  223.             else 
  224.                 printf ("empty_tuple\n");
  225.         }
  226.         else { /* (N_VAL_DEFINED (kind_explored) */
  227.             display_value (node_explored);
  228.             printf ("\n");
  229.         }
  230.  
  231.         printf ("\n");
  232.  
  233.         /*****************/
  234.         /* nu3 component */
  235.         /*****************/
  236.         printf (" nu3 :  ");
  237.  
  238.         if (N_AST3_DEFINED (kind_explored)) {
  239.             if (N_AST3(node_explored) != (Node)0)
  240.                 printf ("AST3 %s \n", kind_str(N_KIND(N_AST3(node_explored))));
  241.             else
  242.                 printf ("AST3 (Node)0 \n");
  243.         }
  244.         else if (N_UNQ_DEFINED (kind_explored))
  245.             printf ("Symbol unq --> %s \n",
  246.               nature_str(NATURE(N_UNQ(node_explored))));
  247.         else {
  248.             printf ("N_NAMES ");
  249.             if (N_NAMES (node_explored) != ((Set)0))
  250.                 display_node_list((Tuple)N_NAMES(node_explored), list_begin);
  251.             else 
  252.                 printf ("empty_set\n");
  253.         }
  254.  
  255.         printf ("\n");
  256.  
  257.         /*****************/
  258.         /* nu4 component */
  259.         /*****************/
  260.         printf (" nu4 :  ");
  261.  
  262.         if (N_AST4_DEFINED (kind_explored)) {
  263.             if (N_AST4(node_explored) != (Node)0)
  264.                 printf ("AST4 %s \n", kind_str(N_KIND(N_AST4(node_explored))));
  265.             else
  266.                 printf ("AST4 (Node)0 \n");
  267.         }
  268.         else if (N_TYPE_DEFINED (kind_explored))
  269.             printf ("Symbol type --> %s \n",
  270.               nature_str(NATURE(N_TYPE(node_explored))));
  271.         else {
  272.             printf ("N_PTYPES ");
  273.             if (N_PTYPES (node_explored) != ((Set)0))
  274.                 display_node_list((Tuple)N_PTYPES(node_explored), list_begin);
  275.             else 
  276.                 printf ("empty_set\n");
  277.         }
  278.         printf ("\n");
  279.     }
  280. }
  281.  
  282. void explorast (Node root)                    /*;explorast*/
  283. {
  284.     explored current;
  285.     int      next_step;
  286.     int      list_node;
  287.     int      list_low;
  288.     char     answer[10];
  289.  
  290.     current.genre = NODE_GENRE;
  291.     current.addr.n = root;
  292.     list_low = 1;
  293.  
  294.     do {
  295.         if (current.genre == NODE_GENRE)
  296.             display_node   (current.addr.n, list_low);
  297.         else 
  298.             display_symbol (current.addr.s);
  299.  
  300.         next_step = UNDEFINED_STEP;
  301.         list_node = 0;
  302.  
  303.         while (next_step == UNDEFINED_STEP) {
  304.             printf (" what shall be the next step  ?  ");
  305.             scanf ("%10s", answer);
  306.             next_step = analyze (answer, current, &list_node, &list_low);
  307.         }
  308.  
  309.         switch (next_step) {
  310.         case 0 :
  311.             current = pop ();
  312.             break;
  313.         case 11:
  314.             push (current);
  315.             current.genre  = NODE_GENRE;
  316.             current.addr.n = N_AST1 (current.addr.n);
  317.             break;
  318.         case 21:
  319.             push (current);
  320.             current.genre  = NODE_GENRE;
  321.             current.addr.n = N_AST2 (current.addr.n);
  322.             break;
  323.         case 22:
  324.             push (current);
  325.             current.genre  = NODE_GENRE;
  326.             current.addr.n = (Node)((N_LIST(current.addr.n))[list_node]);
  327.             break;
  328.         case 31:
  329.             push (current);
  330.             current.genre  = NODE_GENRE;
  331.             current.addr.n = N_AST3 (current.addr.n);
  332.             break;
  333.         case 33:
  334.             push (current);
  335.             current.genre  = SYMBOL_GENRE;
  336.             current.addr.s = N_UNQ (current.addr.n);
  337.             break;
  338.         case 41:
  339.             push (current);
  340.             current.genre  = NODE_GENRE;
  341.             current.addr.n = N_AST4 (current.addr.n);
  342.             break;
  343.         case 43:
  344.             push (current);
  345.             current.genre  = SYMBOL_GENRE;
  346.             current.addr.s = N_TYPE (current.addr.n);
  347.             break;
  348.         case 91:
  349.             push (current);
  350.             current.genre  = SYMBOL_GENRE;
  351.             current.addr.s = TYPE_OF (current.addr.s);
  352.             break;
  353.         case 92:
  354.             push (current);
  355.             current.genre  = SYMBOL_GENRE;
  356.             current.addr.s = SCOPE_OF (current.addr.s);
  357.             break;
  358.         case 93:
  359.             push (current);
  360.             current.genre  = SYMBOL_GENRE;
  361.             current.addr.s = ALIAS (current.addr.s);
  362.             break;
  363.         case 94:
  364.             push (current);
  365.             current.genre  = SYMBOL_GENRE;
  366.             current.addr.s = INIT_PROC (current.addr.s);
  367.             break;
  368.         case 999:
  369.             break;
  370.         }
  371.     } while (next_step != EXIT_STEP);
  372. }
  373.  
  374. int analyze (char *way, explored current, int *p_list_num, int *p_list_low)
  375.                                                                     /*;analyze*/
  376. {
  377.     Node   current_node;
  378.     int    current_kind;
  379.     Symbol current_symbol;
  380.     int    current_nature;
  381.  
  382.     if (current.genre == NODE_GENRE) {
  383.         current_node = current.addr.n;
  384.  
  385.         if (current_node != (Node)0)
  386.             current_kind = N_KIND (current_node);
  387.  
  388.         switch (way [0]) {
  389.         case 'f' : 
  390.             if (stack_ptr == 0) {
  391.                 printf (" Illegal step : You are at the ROOT\n");
  392.                 return (UNDEFINED_STEP);
  393.             }
  394.             else
  395.                 return (0);
  396.         case '1' : 
  397.             if ((current_node != (Node)0) && (N_AST1_DEFINED (current_kind)))
  398.                 return (11);
  399.             else {
  400.                 printf (" Illegal step : AST1 undefined\n");
  401.                 return (UNDEFINED_STEP);
  402.             }
  403.         case '2' : 
  404.             if ((current_node != (Node)0) && (N_AST2_DEFINED (current_kind)))
  405.                 return (21);
  406.             else {
  407.                 printf (" Illegal step : AST2 undefined\n");
  408.                 return (UNDEFINED_STEP);
  409.             }
  410.         case '3' : 
  411.             if ((current_node != (Node)0) && (N_AST3_DEFINED (current_kind)))
  412.                 return (31);
  413.             else {
  414.                 printf (" Illegal step : AST3 undefined\n");
  415.                 return (UNDEFINED_STEP);
  416.             }
  417.         case '4' : 
  418.             if ((current_node != (Node)0) && (N_AST4_DEFINED (current_kind)))
  419.                 return (41);
  420.             else {
  421.                 printf (" Illegal step : AST4 undefined\n");
  422.                 return (UNDEFINED_STEP);
  423.             }
  424.         case 'l' : 
  425.             if ((current_node != (Node)0) && (N_LIST_DEFINED (current_kind))) {
  426.                 if (atoi (way + 1) > 0
  427.                   && atoi (way + 1) <= tup_size(N_LIST(current_node))) {
  428.                     *p_list_num = atoi (way + 1);
  429.                     return (22);
  430.                 }
  431.                 else {
  432.                     printf (" Illegal list number\n");
  433.                     return (UNDEFINED_STEP);
  434.                 }
  435.             }
  436.             else {
  437.                 printf (" Illegal step : LIST undefined\n");
  438.                 return (UNDEFINED_STEP);
  439.             }
  440. #ifdef PRETTY
  441.         case 's' : 
  442.             if ((current_node != (Node)0) && (N_LIST_DEFINED (current_kind))) {
  443.                 if (atoi (way + 1) > 0
  444.                   && atoi (way + 1) <= tup_size(N_LIST(current_node))) {
  445.                     *p_list_num = atoi (way + 1);
  446.                     regenerate_source1( N_LIST(current_node)[*p_list_num],
  447.                       stack[stack_ptr - 1].addr.n);
  448.                     printf("\n");
  449.                     return (UNDEFINED_STEP);
  450.                 }
  451.                 else {
  452.                     printf (" Illegal list number\n");
  453.                     return (UNDEFINED_STEP);
  454.                 }
  455.             }
  456.             else {
  457.                 printf (" Illegal step : LIST undefined\n");
  458.                 return (UNDEFINED_STEP);
  459.             }
  460. #endif
  461.         case 'v' : 
  462.             if ((current_node != (Node)0) && (N_LIST_DEFINED (current_kind))) {
  463.                 if (atoi (way + 1) <= tup_size(N_LIST(current_node))) {
  464.                     *p_list_low = atoi (way + 1);
  465.                     return (999);
  466.                 }
  467.                 else {
  468.                     printf (" Illegal list number\n");
  469.                     return (UNDEFINED_STEP);
  470.                 }
  471.             }
  472.             else {
  473.                 printf (" Illegal step : LIST undefined\n");
  474.                 return (UNDEFINED_STEP);
  475.             }
  476.         case 'u' : 
  477.             if ((current_node != (Node)0) && (N_UNQ_DEFINED (current_kind)))
  478.                 return (33);
  479.             else {
  480.                 printf (" Illegal step : UNQ undefined\n");
  481.                 return (UNDEFINED_STEP);
  482.             }
  483.         case 't' : 
  484.             if ((current_node != (Node)0) && (N_TYPE_DEFINED (current_kind)))
  485.                 return (43);
  486.             else {
  487.                 printf (" Illegal step : TYPE undefined\n");
  488.                 return (UNDEFINED_STEP);
  489.             }
  490.         case 'q' : 
  491.             stack_ptr = 0;
  492.             return (EXIT_STEP);
  493.         case 'h' : 
  494.             printf (" 1     ==> see AST1            \n");
  495.             printf (" 2     ==> see AST2            \n");
  496.             printf (" 3     ==> see AST3            \n");
  497.             printf (" 4     ==> see AST4            \n");
  498.             printf (" l num ==> see list node num   \n");
  499.             printf (" v num ==> see list begin num  \n");
  500.             printf (" u     ==> see unq             \n");
  501.             printf (" t     ==> see type            \n");
  502.             return (UNDEFINED_STEP);
  503.         default  : 
  504.             printf(" I do not understand where you want to go\n");
  505.             return (UNDEFINED_STEP);
  506.         }
  507.     }
  508.     else {
  509.         current_symbol = current.addr.s;
  510.  
  511.         if (current_symbol != (Symbol)0)
  512.             current_nature = NATURE (current_symbol);
  513.  
  514.         switch (way [0]) {
  515.         case 'f' : 
  516.             if (stack_ptr == 0) {
  517.                 printf (" Illegal step : You are at the ROOT\n");
  518.                 return (UNDEFINED_STEP);
  519.             }
  520.             else
  521.                 return (0);
  522.         case 't' : 
  523.             return (91);
  524.         case 's' : 
  525.             return (92);
  526.         case 'a' : 
  527.             return (93);
  528.         case 'i' : 
  529.             return (94);
  530.         case 'q' : 
  531.             stack_ptr = 0;
  532.             return (EXIT_STEP);
  533.         case 'h' : 
  534.             printf (" t ==> see TYPE_OF   \n");
  535.             printf (" s ==> see SCOPE_OF  \n");
  536.             printf (" a ==> see ALIAS     \n");
  537.             printf (" i ==> see INIT_PROC \n");
  538.             return (UNDEFINED_STEP);
  539.         default  : 
  540.             printf(" I do not understand where you want to go\n");
  541.             return (UNDEFINED_STEP);
  542.         }
  543.     }
  544. }
  545.  
  546. void display_node_list (Tuple tup, int low)                /*;display_node_list*/
  547. {
  548.     int high, i, n;
  549.  
  550.     n = tup_size(tup);
  551.     printf("size : %d\n", n);
  552.     high = low + 10;
  553.     if (high > n)
  554.         high = n;
  555.     for (i = low; i <= high; i++)
  556.         printf("%d 0x%x %d %s \n", i, (int)tup[i], (int)tup[i],
  557.           kind_str(N_KIND((Node)tup[i])));
  558. }
  559.  
  560. void display_symbol_list (Tuple tup, int low)        /*;display_symbol_list*/
  561. {
  562.     int high, i, n;
  563.  
  564.     n = tup_size(tup);
  565.     printf(" size : %d\n", n);
  566.     high = low + 10;
  567.     if (high > n)
  568.         high = n;
  569.     for (i = low; i <= high; i++) {
  570.         printf(" ");
  571.         give_symbol_reference((Symbol)tup[i]);
  572.         zpsymrefa("type_of", TYPE_OF((Symbol)tup[i]));
  573.         zpsymrefa("scope", SCOPE_OF((Symbol)tup[i]));
  574.         if (ORIG_NAME((Symbol)tup[i]) != (char *)0)
  575.             printf(" :%s", ORIG_NAME((Symbol)tup[i]));
  576.         printf("\n");
  577.     }
  578. }
  579.  
  580. void display_value (Node node_explored)                /*;display_value*/
  581. {
  582.     int kind_explored, constant_kind;
  583.     Const constant_explored;
  584.     Rational rational_explored;
  585.     Tuple tup;
  586.     int i, n;
  587.  
  588.     kind_explored = N_KIND (node_explored);
  589.  
  590.     if (kind_explored == as_simple_name
  591.       || kind_explored == as_int_literal
  592.       || kind_explored == as_real_literal
  593.       || kind_explored == as_string_literal
  594.       || kind_explored == as_character_literal
  595.       || kind_explored == as_subprogram_stub_tr
  596.       || kind_explored == as_package_stub
  597.       || kind_explored == as_task_stub)
  598.         printf ("%s", N_VAL (node_explored));
  599.     else if (kind_explored == as_line_no
  600.       || kind_explored == as_number
  601.       || kind_explored == as_predef)
  602.         printf ("%d", (int) N_VAL (node_explored));
  603.     else if (kind_explored == as_mode)
  604.         printf ("%d", (int) N_VAL (node_explored));
  605.     else if (kind_explored == as_ivalue) {
  606.         constant_explored = (Const) N_VAL (node_explored);
  607.         constant_kind = constant_explored -> const_kind;
  608.         if (NATURE(N_TYPE(node_explored)) == na_enum)
  609.             printf ("%s", OVERLOADS(N_TYPE(node_explored))
  610.               [2*constant_explored->const_value.const_int+1]);
  611.         else {
  612.             if (constant_kind == CONST_INT)
  613.                 printf ("%d",  constant_explored->const_value.const_int);
  614.             else if (constant_kind == CONST_REAL)
  615.                 printf ("%f", constant_explored->const_value.const_real);
  616.             else if (constant_kind == CONST_UINT)
  617.                 printf ("%d", constant_explored->const_value.const_uint);
  618.             else if (constant_kind == CONST_OM)
  619.                 printf ("OM");
  620.             else if (constant_kind == CONST_RAT) {
  621.                 rational_explored = constant_explored-> const_value.const_rat;
  622.                 printf ("num %d den %d", rational_explored -> rnum,
  623.                   rational_explored -> rden);
  624.             }
  625.             else if (constant_kind == CONST_CONSTRAINT_ERROR)
  626.                 printf ("CONSTANT_CONSTRAINT_ERROR");
  627.         }
  628.     }
  629.     else if (kind_explored == as_terminate_alt)
  630.     printf ("%d", (int) N_VAL (node_explored));
  631.     else if (kind_explored == as_string_ivalue) {
  632.         /* N_VAL is a tuple of integer */
  633.         printf ("\"");
  634.         tup = (Tuple) N_VAL (node_explored);
  635.         n = tup_size (tup);
  636.         for (i = 1; i <= n; i++)
  637.             printf ("%c", tup [i]);
  638.         printf ("\"");
  639.     }
  640.     else if (kind_explored == as_null)
  641.         printf ("null");
  642.     else if (kind_explored == as_null_s)
  643.         printf ("null;");
  644.     else if (kind_explored == as_others)
  645.         printf ("others");
  646.     else if (kind_explored == as_generic)
  647.         printf ("(<>)");
  648.     else if (kind_explored == as_instance_tuple)
  649.         printf (" ??????? ");
  650. }
  651.  
  652. void display_signature (Symbol sym)                 /*;display_signature*/
  653. {
  654.     int nat, i, n, ctyp;
  655.     Tuple    sig, tup, tupent;
  656.     Symbol    s;
  657.     Fortup    ft1;
  658.     static char *constraint_types[] = {
  659.       "range", "digits", "delta", "discr", "array" };
  660.  
  661.  
  662.     /* The signature field is used as follows:
  663.      * It is a symbol for:
  664.      *    na_access
  665.      * It is a node for
  666.      *    na_constant  na_in  na_inout
  667.      * It is also a node (always OPT_NODE) for na_out. For now we write this
  668.      * out even though it is not used. 
  669.      * It is a pair for na_array.
  670.      * It is a triple for na_enum.
  671.      * It is a triple for na_generic_function_spec na_generic_procedure_spec
  672.      * The first component is a tuple of pairs, each pair consisting of
  673.      * a symbol and a (default) node.
  674.      * The second component is a tuple of symbols.
  675.      * The third component is a node
  676.      * It is a tuple with four elements for na_generic_package_spec:
  677.      * the first is a tuple of pairs, with same for as for generic procedure.
  678.      * the second third, and fourth components are nodes.
  679.      * It is a 5-tuple for na_record.
  680.      * It is a constraint for na_subtype and na_type.
  681.      * It is a node for na_obj.
  682.      * Otherwise it is the signature for a procedure, namely a tuple
  683.      * of quadruples.
  684.      * Note however, that for a private type, the signature has the same
  685.      * form as for a record.
  686.      * For a subtype whose root type is an array, the signature has the
  687.      * same form as for an array.
  688.      */
  689.  
  690.     nat = NATURE(sym);
  691.     sig = SIGNATURE(sym);
  692.  
  693.     /* treat private types way in same way as for records*/
  694.  
  695.     s = TYPE_OF(sym);
  696.     if (s == symbol_private || s == symbol_limited_private
  697.       || s == symbol_incomplete)
  698.         nat = na_record;
  699.  
  700.     switch (nat) {
  701.     case na_access: 
  702.         /* access: signature is designated_type;*/
  703.         (void) give_symbol_reference ((Symbol) sig);
  704.         break;
  705.  
  706.     case na_array:
  707.     array_case:
  708.         /* array: signature is pair [i_types, comp_type] where
  709.          * i_type is tuple of type names
  710.          */
  711.         printf(" array_sig %d\n", tup_size((Tuple) sig[1]));
  712.         FORTUP(s = (Symbol), (Tuple) sig[1], ft1);
  713.             (void) give_symbol_reference (s);
  714.             printf("\n");
  715.         ENDFORTUP(ft1);
  716.         (void) give_symbol_reference ((Symbol) sig[2]);
  717.         printf("\n");
  718.         break;
  719.  
  720.     case    na_block:
  721.         /* block: miscellaneous information */
  722.         /* This information not needed externally*/
  723.         printf ("signature for block\n");
  724.         break;
  725.  
  726.     case    na_constant:
  727.     case    na_in:
  728.     case    na_inout:
  729.     case    na_out:
  730.     case    na_discriminant:
  731.         (void) give_node_reference ((Node) sig);
  732.         break;
  733.  
  734.     case    na_entry:
  735.     case    na_entry_family:
  736.     case    na_entry_former:
  737.         /*  entry: list of symbols */
  738.     case    na_function:
  739.     case    na_function_spec:
  740.     case    na_literal:        /* is this for literals too? */
  741.     case    na_op:
  742.     case    na_procedure:
  743.     case    na_procedure_spec:
  744.         printf(" symbol_list  %d\n", tup_size(sig));
  745.         FORTUP(s = (Symbol), sig, ft1);
  746.             (void) give_symbol_reference(s); 
  747.             printf("\n");
  748.         ENDFORTUP(ft1);
  749.         break;
  750.  
  751.     case na_enum : 
  752.         /* enum: tuple in form ['range', lo, hi]*/
  753.         /* we write this as two node references*/
  754.         (void) give_node_reference ((Node) sig[2]);
  755.         (void) give_node_reference ((Node) sig[3]);
  756.         printf ("\n");
  757.         break;
  758.  
  759.     case na_type: 
  760.     case na_subtype:
  761.         if (nat == na_subtype && is_access(TYPE_OF(sym)))
  762.         /* subtype of access type, signature is anonymous type */
  763.             (void) give_symbol_reference ((Symbol)sig);
  764.         else {
  765.             n = tup_size(sig);
  766.             if (is_array (sym)) {
  767.                 printf(" constrained_array \n");
  768.                 goto array_case;
  769.             }
  770.             ctyp = (int) sig[1];
  771.             if (ctyp >= 0 && ctyp <= 4)
  772.                 printf(" co_%s", constraint_types[ctyp]);
  773.             else
  774.                 printf(" unknown constraint type %d", ctyp);
  775.             if (ctyp == CONSTRAINT_DISCR) {
  776.                 /* discriminant map */
  777.                 tup = (Tuple) numeric_constraint_discr(sig);
  778.                 n = tup_size(tup);
  779.                 for (i = 1; i <= n; i += 2) {
  780.                     printf(" %d", (i+1)/2);
  781.                     (void) give_symbol_reference ((Symbol) sig[i]);
  782.                     (void) give_node_reference ((Node) sig[i+1]);
  783.                 }
  784.             }
  785.             else {
  786.                 for (i = 2; i <= n; i++) {
  787.                     printf(" %d", i);
  788.                     (void) give_node_reference ((Node) sig[i]);
  789.                 }
  790.             }
  791.         }
  792.         printf("\n");
  793.         break;
  794.  
  795.     case    na_generic_function:
  796.     case    na_generic_procedure:
  797.     case    na_generic_function_spec:
  798.     case    na_generic_procedure_spec:
  799.         if (tup_size(sig) != 3)
  800.             printf ("bad signature for na_generic_procedure_spec\n");
  801.         /* tuple count known to be three, just put elements */
  802.         tup = (Tuple) sig[1];
  803.         /* the first component is a tuple of pairs, just write count
  804.          * and the values of the successive pairs 
  805.          */
  806.         n = tup_size(tup);
  807.         printf(" %d\n", n);
  808.         for (i = 1; i <= n; i++) {
  809.             tupent = (Tuple) tup[i];
  810.             (void) give_symbol_reference((Symbol) tupent[1]);
  811.             (void) give_node_reference ((Node) tupent[2]);
  812.             printf("\n");
  813.         }
  814.         tup = (Tuple) sig[2];
  815.         n = tup_size(tup); /* symbol list */
  816.         printf(" symbol_list %d\n", n);
  817.         for (i = 1; i <= n; i++) {
  818.             (void) give_symbol_reference ((Symbol) tup[i]); 
  819.             printf("\n");
  820.         }
  821.         printf(" node ");
  822.         (void) give_node_reference((Node) sig[3]);
  823.         printf("\n");
  824.         break;
  825.  
  826.     case    na_generic_package_spec:
  827.     case    na_generic_package:
  828.         /* signature is tuple with three elements */
  829.         if (tup_size(sig) != 4)
  830.             printf ("bad signature for na_generic_package_spec\n");
  831.         tup = (Tuple) sig[1];
  832.         /* the first component is a tuple of pairs, just write count
  833.          * and the values of the successive pairs 
  834.          */
  835.         n = tup_size(tup);
  836.         printf(" n %d\n", n);
  837.         for (i = 1; i <= n; i++) {
  838.             tupent = (Tuple) tup[i];
  839.             (void) give_symbol_reference ((Symbol) tupent[1]);
  840.             (void) give_node_reference ((Node) tupent[2]);
  841.             printf("\n");
  842.         }
  843.         /* the second third, and fourth components are just nodes */
  844.         (void) give_node_reference ((Node) sig[2]);
  845.         (void) give_node_reference ((Node) sig[3]);
  846.         (void) give_node_reference ((Node) sig[4]);
  847.         printf("\n");
  848.         break;
  849.  
  850.     case    na_record:
  851.         /* the signature is tuple with five components:
  852.          * [node, node, tuple of symbols, declaredmap, node]
  853.          * NOTE: we do not write component count - 5 assumed 
  854.          */
  855.         printf(" record (skip details)\n"); 
  856.         break;
  857. /*
  858.         (void) give_node_reference ((Node) sig[1]);
  859.         (void) give_node_reference ((Node) sig[2]);
  860.         tup = (Tuple) sig[3];
  861.         n = tup_size(tup);
  862.         for (i = 1; i <= n; i++)
  863.             zpsymref((Symbol) tup[i]);
  864.  
  865. #ifdef SKIP
  866.         -- cant use putdcl now since its first arg is OFILE  ds 11-30-85
  867.             putdcl((Declaredmap) sig[4]);
  868. #else
  869.         printf("putdcl call bypassed\n");
  870. #endif    
  871.         (void) give_node_reference ((Node) sig[5]);
  872.         break;
  873. */
  874.  
  875.     case    na_void:
  876.         /* special case assume entry for $used, in which case is tuple
  877.          * of symbols
  878.          */
  879.         if (streq(ORIG_NAME(sym), "$used")) {
  880.             n = tup_size(sig);
  881.             printf(" symbol_list %d\n", n);
  882.             for (i = 1; i <= n; i++) {
  883.                 (void) give_symbol_reference ((Symbol) sig[i]); 
  884.                 printf("\n");
  885.             }
  886.         }
  887.         else {
  888.             (void) give_symbol_reference(sym);
  889.             printf ("na_void, not $used\n");
  890.         }
  891.         break;
  892.  
  893.     case na_obj:
  894.         (void) give_node_reference ((Node) sig); 
  895.         printf("\n");
  896.         break;
  897.  
  898.     default:
  899.         printf("display_signature : default error\n");
  900.     }
  901. }
  902.  
  903. void give_node_reference (Node node)            /*;give_node_reference*/
  904. {
  905.     if (node == (Node)0)
  906.         printf (" (Node)0 \n");
  907.     else
  908.         printf(" n%du%d %d%s", N_SEQ (node), N_UNIT (node), node,
  909.           kind_str (N_KIND (node)));
  910. }
  911.  
  912. void give_symbol_reference (Symbol symbol)        /*;give_symbol_reference*/
  913. {
  914.     if (symbol == (Symbol)0)
  915.         printf (" (Symbol)0 \n");
  916.     else
  917.         printf(" s%du%d %d%s", S_SEQ (symbol), S_UNIT (symbol), symbol,
  918.           nature_str (NATURE (symbol)));
  919. }
  920.  
  921. void zpadr(char *s, char *p)            /*;zpadr*/
  922. {
  923.     /* print argument as address */
  924.     if (zpadr_opt == 0) return; /* quit if disabled */
  925.     if (p == (char *)0) return; /* don't print if null pointer */
  926.     if (!adrflag) return;
  927.     if (s != (char *)0) {
  928. #ifdef IBM_PC
  929.         printf(" %s %p", s, p);
  930. #else
  931.         printf(" %s %ld", s, p);
  932. #endif
  933.     }
  934.     else {
  935. #ifdef IBM_PC
  936.         printf(" %p", p);
  937. #else
  938.         printf(" %ld", p);
  939. #endif
  940.     }
  941. }
  942.  
  943. void zpstr(char *str)                                            /*;zpstr*/
  944. {
  945.     printf("%s\n", str);
  946. }
  947.  
  948. void zpcon(Const con)                                            /*;zpcon*/
  949. {
  950.     zpcon1(con);
  951.     printf("\n");
  952. }
  953.  
  954. static void zpcon1(Const con)                                    /*;zpcon1*/
  955. {
  956.     int    k;
  957.     char    *s;
  958.  
  959.     k = con->const_kind;
  960.     if (k == CONST_OM) s = "om";
  961.     else if (k== CONST_INT) s = "int";
  962.     else if (k == CONST_REAL) s = "real";
  963.     else if (k == CONST_STR) s = "str";
  964.     else if (k == CONST_RAT) s = "rat";
  965.     else if (k == CONST_CONSTRAINT_ERROR) s = "constraint_error";
  966.     else if (k == CONST_UINT) s = "uint";
  967.     else if (k == CONST_FIXED) s = "fixed";
  968.     else s = "INVALID";
  969.     printf(" %s", s);
  970.     if (k == CONST_INT) printf(" %d", con->const_value.const_int);
  971.     else if (k == CONST_UINT)printf(" %s",int_tos(con->const_value.const_uint));
  972.     else if (k == CONST_REAL) printf(" %12.3g", con->const_value.const_real);
  973.     else if (k == CONST_STR) printf(" %s", con->const_value.const_str);
  974.     else if (k == CONST_RAT) zprat1(RATV(con));
  975.     else if (k == CONST_FIXED) printf("%ld", con->const_value.const_fixed);
  976. }
  977.  
  978. static void zprat1(Rational rat)                    /*;zprat1*/
  979. {
  980.     char    *s1, *s2;
  981.  
  982.     s1 = int_tos(rat->rnum);
  983.     s2 = int_tos(rat->rden);
  984.     printf(" %s/%s", s1, s2);
  985.     efreet(s1, "zprat1-num"); 
  986.     efreet(s2, "zprat1-den");
  987. }
  988.  
  989. void zprat(Rational rat)                    /*;zprat*/
  990. {
  991.     zprat1(rat);
  992.     printf("\n");
  993. }
  994.  
  995. void zpnod(Node nod)                    /*;zpnod*/
  996. {
  997.     int    i, seq, unit, has_spans;
  998.     unsigned int nk;
  999.     Symbol    sym;
  1000.  
  1001.     if (nod == (Node)0) {
  1002.         printf("(Node)0\n");
  1003.         return;
  1004.     }
  1005.     printf("=n%du%d", N_SEQ(nod), N_UNIT(nod));
  1006.     zpadr((char *)0, (char *) nod);
  1007.     nk = N_KIND(nod);
  1008.     printf(" %s", kind_str(nk));
  1009.     if (N_LIST_DEFINED(nk)) zpadr("n_list", (char *) N_LIST(nod));
  1010.     has_spans = is_terminal_node(nk);
  1011.     if (has_spans) {
  1012.         printf(" n_span %d", N_SPAN0(nod));
  1013.         printf(".%d", N_SPAN1(nod));
  1014.     }
  1015.     sym = (Symbol) 0;
  1016.     /* indicate if overloaded */
  1017.     if (N_OVERLOADED(nod)) printf(" OV ");
  1018.     /* N_UNQ defined only if N_AST3 not defined */
  1019.     if (!N_AST3_DEFINED(nk)) sym = N_UNQ(nod);
  1020.     if (sym != (Symbol)0) { /* only do N_UNQ if not overloaded */
  1021.         if (!N_OVERLOADED(nod)) {
  1022.             seq = S_SEQ(sym); 
  1023.             unit = S_UNIT(sym);
  1024.             zpsymrefa("n_unq", N_UNQ(nod));
  1025.         }
  1026.     }
  1027.     if (!N_AST3_DEFINED(nk)) { /* N_AST3 and N_NAMES overlap */
  1028.         if (N_OVERLOADED(nod)) zpadr("n_names", (char *) N_NAMES(nod));
  1029.     }
  1030.  
  1031.     sym = (Symbol)0;
  1032.     /* N_TYPE defined only if N_AST4 not defined */
  1033.     if (!N_AST4_DEFINED(nk)) sym = N_TYPE(nod);
  1034.     if (!N_OVERLOADED(nod) && sym != (Symbol)0)
  1035.         zpsymrefa("n_type", N_TYPE(nod));
  1036.     if (!N_AST4_DEFINED(nk)) { /* N_PTYPES overlaps N_AST4 */
  1037.         if (N_OVERLOADED(nod)) zpadr("n_ptypes", (char *) N_PTYPES(nod));
  1038.     }
  1039.  
  1040.     if (N_KIND(nod) == as_line_no || N_KIND(nod) == as_number)
  1041.         printf(" %d", (int)N_VAL(nod));
  1042.     else if (N_KIND(nod) == as_ivalue) {
  1043.         printf(" ");
  1044.         zpcon1((Const) N_VAL(nod));
  1045.     }
  1046.     else {
  1047.         if (N_VAL_DEFINED(nk)) zpadr("n_val",  N_VAL(nod));
  1048.         if (N_LIST_DEFINED(nk)) zpadr("n_list",  (char *) N_LIST(nod));
  1049.     }
  1050.     if (N_KIND(nod) == as_simple_name) printf(" %s", N_VAL(nod));
  1051.     printf("\n");
  1052.     if (N_AST1(nod) != (Node) 0 || N_AST2(nod) != (Node) 0
  1053.       || N_AST3(nod) != (Node) 0 || N_AST4(nod) != (Node) 0) {
  1054.         i = 0; /* set if any subnodes found, to see if newline needed*/
  1055.         if (N_AST1_DEFINED(nk) && N_AST1(nod) != (Node) 0)  {
  1056.             zpnodrefa("1", N_AST1(nod));
  1057.             i = 1;
  1058.         }
  1059.         if (N_AST2_DEFINED(nk) &&  N_AST2(nod) != (Node) 0)  {
  1060.             zpnodrefa("2", N_AST2(nod));
  1061.             i = 1;
  1062.         }
  1063.         if (N_AST3_DEFINED(nk) && N_AST3(nod) != (Node) 0)  {
  1064.             zpnodrefa("3", N_AST3(nod));
  1065.             i = 1;
  1066.         }
  1067.         if (N_AST4_DEFINED(nk) && N_AST4(nod) != (Node) 0) {
  1068.             zpnodrefa("4", N_AST4(nod));
  1069.             i = 1;
  1070.         }
  1071.         if (i) printf("\n");
  1072.     }
  1073. #ifdef AMIABLE
  1074.     zpoperand(nod);
  1075. #endif
  1076. }
  1077.  
  1078. void zpnods(int seq, int unit)            /*;zpnods*/
  1079. {
  1080.     /* node dump by sequence and unit number */
  1081.     Node node;
  1082.  
  1083.     node = zgetnodptr(seq, unit);
  1084.     zpnod(node);
  1085. }
  1086.  
  1087. void zpn(int seq, int unit)                    /*;zpn*/
  1088. {
  1089.     /* short name for zpnods */
  1090.     zpnods(seq, unit);
  1091. }
  1092.  
  1093.  
  1094. void zpdnod() /*;zpdnod*/
  1095. {
  1096.     zpnod(znod);
  1097. }
  1098.  
  1099. void zpnodrefa(char *s, Node nod)                    /*;zpnodrefa*/
  1100. {
  1101.     printf(" %s", s); 
  1102.     zpnodref(nod);
  1103.     /*zpadr((char *)0, nod);*/
  1104. }
  1105.  
  1106. void zpdset()    /*;zpdset*/
  1107. {
  1108.     zpset(zset);
  1109. }
  1110.  
  1111. void zpset(Set s)    /*;zpset*/
  1112. {
  1113.     zptup(s);
  1114. }
  1115.  
  1116. void zpdsetsym()    /*;zpdsetsym*/
  1117. {
  1118.     zpsetsym(zset);
  1119. }
  1120.  
  1121. void zpsetsym(Set s)    /*zpsetsym*/
  1122. {
  1123.     Symbol    sym;
  1124.     int n;
  1125.     Forset    fs1;
  1126.  
  1127.     n = set_size(s);
  1128.     printf("setsym %d {", n);
  1129.     if (n>10) n = 10;
  1130.     FORSET(sym = (Symbol), s, fs1);
  1131.         zpsym(sym);
  1132.     ENDFORSET(fs1);
  1133.     printf(" }\n");
  1134. }
  1135.  
  1136. void zpsigs(int seq, int unit)            /*;zpsigs*/
  1137. {
  1138.     /* signature dump by sequence and unit number */
  1139.     Symbol sym;
  1140.     sym = zgetsymptr(seq, unit);
  1141.     zpsig(sym);
  1142. }
  1143.  
  1144. void zpsig(Symbol sym)                /*;zpsig*/
  1145. {
  1146.     int nat, i, n, ctyp;
  1147.     Tuple    sig, tup, tupent;
  1148.     Symbol    s;
  1149.     Fortup    ft1;
  1150.     static char *constraint_types[] = { 
  1151.         "range", "digits", "delta", "discr", "array" };
  1152.  
  1153.  
  1154.     /* The signature field is used as follows:
  1155.      * It is a symbol for:
  1156.      *    na_access
  1157.      * It is a node for
  1158.      *    na_constant  na_in  na_inout
  1159.      * It is also a node (always OPT_NODE) for na_out. For now we write this
  1160.      * out even though it is not used. 
  1161.      * It is a pair for na_array.
  1162.      * It is a triple for na_enum.
  1163.      * It is a triple for na_generic_function_spec na_generic_procedure_spec
  1164.      * The first component is a tuple of pairs, each pair consisting of
  1165.      * a symbol and a (default) node.
  1166.      * The second component is a tuple of symbols.
  1167.      * The third component is a node
  1168.      * It is a tuple with four elements for na_generic_package_spec:
  1169.      * the first is a tuple of pairs, with same for as for generic procedure.
  1170.      * the second third, and fourth components are nodes.
  1171.      * It is a 5-tuple for na_record.
  1172.      * It is a constraint for na_subtype and na_type.
  1173.      * It is a node for na_obj.
  1174.      * Otherwise it is the signature for a procedure, namely a tuple
  1175.      * of quadruples.
  1176.      * Note however, that for a private type, the signature has the same
  1177.      * form as for a record.
  1178.      * For a subtype whose root type is an array, the signature has the
  1179.      * same form as for an array.
  1180.      */
  1181.  
  1182.     nat = NATURE(sym);
  1183.     sig = SIGNATURE(sym);
  1184.     /* treat private types way in same way as for records*/
  1185.     s = TYPE_OF(sym);
  1186.     if (s == symbol_private || s == symbol_limited_private
  1187.       || s== symbol_incomplete) {
  1188.         nat = na_record;
  1189.     }
  1190.     switch (nat) {
  1191.     case na_access:
  1192.         /* access: signature is designated_type;*/
  1193.         zpsymref((Symbol) sig);
  1194.         break;
  1195.  
  1196.     case    na_array:
  1197.         /* array: signature is pair [i_types, comp_type] where
  1198.          * i_type is tuple of type names
  1199.          */
  1200. array_case:
  1201.         printf(" array_sig %d\n", tup_size((Tuple) sig[1]));
  1202.         FORTUP(s = (Symbol), (Tuple) sig[1], ft1);
  1203.             zpsymref(s);
  1204.             printf("\n");
  1205.         ENDFORTUP(ft1);
  1206.         zpsymref((Symbol) sig[2]);
  1207.         printf("\n");
  1208.         break;
  1209.  
  1210.     case    na_block:
  1211.         /* block: miscellaneous information */
  1212.         /* This information not needed externally*/
  1213.         chaos("zpsig: signature for block");
  1214.         break;
  1215.  
  1216.     case    na_constant:
  1217.     case    na_in:
  1218.     case    na_inout:
  1219.     case    na_out:
  1220.     case    na_discriminant:
  1221.         zpnodref((Node) sig);
  1222.         break;
  1223.  
  1224.     case    na_entry:
  1225.     case    na_entry_family:
  1226.     case    na_entry_former:
  1227.         /* entry: list of symbols */
  1228.     case    na_function:
  1229.     case    na_function_spec:
  1230.     case    na_literal:        /* is this for literals too? */
  1231.     case    na_op:
  1232.     case    na_procedure:
  1233.     case    na_procedure_spec:
  1234.         printf(" symbol_list  %d\n", tup_size(sig));
  1235.         FORTUP(s = (Symbol), sig, ft1);
  1236.             zpsymref(s); 
  1237.             printf("\n");
  1238.         ENDFORTUP(ft1);
  1239.         break;
  1240.  
  1241.     case    na_enum:
  1242.         /* enum: tuple in form ['range', lo, hi]*/
  1243.         /* we write this as two node references*/
  1244.         zpnodref((Node) sig[2]);
  1245.         zpnodref((Node) sig[3]);
  1246.         printf("\n");
  1247.         break;
  1248.  
  1249.     case    na_type: 
  1250.     case na_subtype:
  1251.         if (nat == na_subtype && is_access(TYPE_OF(sym))) {
  1252.             /* subtype of access type, signature is anonymous type */
  1253.             zpsymref((Symbol)sig);
  1254.         }
  1255.         else {
  1256.             n = tup_size(sig);
  1257.             if (is_array(sym)) { /* if constrained array */
  1258.                 printf(" constrained_array \n");
  1259.                 goto array_case;
  1260.             }
  1261.             ctyp = (int) sig[1];
  1262.             if (ctyp >= 0 && ctyp <= 4)
  1263.                 printf(" co_%s", constraint_types[ctyp]);
  1264.             else
  1265.                 printf(" unknown constraint type %d", ctyp);
  1266.             if (ctyp == CONSTRAINT_DISCR) {
  1267.                 /* discriminant map */
  1268.                 tup = (Tuple) numeric_constraint_discr(sig);
  1269.                 n = tup_size(tup);
  1270.                 for (i = 1; i <= n; i += 2) {
  1271.                     printf(" %d", (i+1)/2);
  1272.                     zpsymref((Symbol) sig[i]);
  1273.                     zpnodref((Node) sig[i+1]);
  1274.                 }
  1275.             }
  1276.             else {
  1277.                 for (i = 2; i <= n; i++) {
  1278.                     printf(" %d", i);
  1279.                     zpnodref((Node) sig[i]);
  1280.                 }
  1281.             }
  1282.         }
  1283.         printf("\n");
  1284.         break;
  1285.  
  1286.     case    na_generic_function:
  1287.     case    na_generic_procedure:
  1288.     case    na_generic_function_spec:
  1289.     case    na_generic_procedure_spec:
  1290.         if (tup_size(sig) != 3)
  1291.             chaos("zpsig: bad signature for na_generic_procedure_spec");
  1292.         /* tuple count known to be three, just put elements */
  1293.         tup = (Tuple) sig[1];
  1294.         /* the first component is a tuple of pairs, just write count
  1295.          * and the values of the successive pairs 
  1296.          */
  1297.         n = tup_size(tup);
  1298.         printf(" %d\n", n);
  1299.         for (i = 1; i <= n; i++) {
  1300.             tupent = (Tuple) tup[i];
  1301.             zpsymref((Symbol) tupent[1]);
  1302.             zpnodref((Node) tupent[2]);
  1303.             printf("\n");
  1304.         }
  1305.         tup = (Tuple) sig[2];
  1306.         n = tup_size(tup); /* symbol list */
  1307.         printf(" symbol_list %d\n", n);
  1308.         for (i = 1; i <= n; i++) {
  1309.             zpsymref((Symbol) tup[i]); 
  1310.             printf("\n");
  1311.         }
  1312.         printf(" node ");
  1313.         zpnodref((Node) sig[3]);
  1314.         printf("\n");
  1315.         break;
  1316.  
  1317.     case    na_generic_package_spec:
  1318.     case    na_generic_package:
  1319.         /* signature is tuple with three elements */
  1320.         if (tup_size(sig) != 4)
  1321.             chaos("zpsig: bad signature for na_generic_package_spec");
  1322.         tup = (Tuple) sig[1];
  1323.         /* the first component is a tuple of pairs, just write count
  1324.          * and the values of the successive pairs 
  1325.          */
  1326.         n = tup_size(tup);
  1327.         printf(" n %d\n", n);
  1328.         for (i = 1; i <= n; i++) {
  1329.             tupent = (Tuple) tup[i];
  1330.             zpsymref((Symbol) tupent[1]);
  1331.             zpnodref((Node) tupent[2]);
  1332.             printf("\n");
  1333.         }
  1334.         /* the second third, and fourth components are just nodes */
  1335.         zpnodref((Node) sig[2]);
  1336.         zpnodref((Node) sig[3]);
  1337.         zpnodref((Node) sig[4]);
  1338.         printf("\n");
  1339.         break;
  1340.  
  1341.     case    na_record:
  1342.         /* the signature is tuple with five components:
  1343.          * [node, node, tuple of symbols, declaredmap, node]
  1344.          * NOTE: we do not write component count - 5 assumed 
  1345.          */
  1346.         printf(" record (skip details)\n"); 
  1347.         break;
  1348. /*
  1349.         zpnodref((Node) sig[1]);
  1350.         zpnodref((Node) sig[2]);
  1351.         tup = (Tuple) sig[3];
  1352.         n = tup_size(tup);
  1353.         for (i = 1; i <= n; i++)
  1354.             zpsymref((Symbol) tup[i]);
  1355. #ifdef SKIP
  1356.         -- cant use putdcl now since its first arg is OFILE  ds 11-30-85
  1357.             putdcl((Declaredmap) sig[4]);
  1358. #else
  1359.         printf("putdcl call bypassed\n");
  1360. #endif    
  1361.         zpnodref((Node) sig[5]);
  1362.         break;
  1363. */
  1364.  
  1365.     case    na_void:
  1366.         /* special case assume entry for $used, in which case is tuple
  1367.          * of symbols
  1368.          */
  1369.         if (streq(ORIG_NAME(sym), "$used")) {
  1370.             n = tup_size(sig);
  1371.             printf(" symbol_list %d\n", n);
  1372.             for (i = 1; i <= n; i++) {
  1373.                 zpsymref((Symbol) sig[i]); 
  1374.                 printf("\n");
  1375.             }
  1376.         }
  1377.         else {
  1378.             zpsym(sym);
  1379.             chaos("zpsig: na_void, not $used");
  1380.         }
  1381.         break;
  1382.  
  1383.     case    na_obj:
  1384.         zpnodref((Node) sig); 
  1385.         printf("\n");
  1386.         break;
  1387.  
  1388.     default:
  1389.         printf("zpsig: default error\n");
  1390.         zpsigt();
  1391.     }
  1392. }
  1393.  
  1394. void zpsigt()
  1395. {
  1396. }
  1397.  
  1398. void zptup(Tuple tup) /*;zptup*/
  1399. {
  1400.     int i, n;
  1401.     n = tup_size(tup);
  1402.     printf("size : %d\n", n);
  1403.     if (n>10) n = 10;
  1404.     for (i = 1; i <= n; i++)
  1405.         printf("%d 0x%x %d \n", i, (int)tup[i], (int)tup[i]);
  1406. }
  1407.  
  1408. void zpdtup()
  1409. {
  1410.     zptup(ztup);
  1411. }
  1412.  
  1413. void zpsym(Symbol sym)            /*;zpsym*/
  1414. {
  1415.     /* kind_char gives character for TYPE_KIND - B for byte, etc. */
  1416.     static char kind_char[] = {
  1417.         'U', 'B', 'W', 'A', 'L', 'D', 'X' };
  1418.  
  1419.     if (sym == (Symbol)0) {
  1420.         printf("(Symbol)0\n");
  1421.         return;
  1422.     }
  1423.     printf("=s%du%d", S_SEQ(sym), S_UNIT(sym));
  1424.     zpadr((char *)0, (char *) sym);
  1425.     /*printf(" %d %s ", (int)NATURE(sym), nature_str(NATURE(sym)));*/
  1426.     printf(" %s", nature_str(NATURE(sym)));
  1427.     zpsymrefa("type_of", TYPE_OF(sym));
  1428.     zpsymrefa("scope", SCOPE_OF(sym));
  1429.     zpadr("sig", (char *) SIGNATURE(sym));
  1430.     printf(" %c%d", kind_char[TYPE_KIND(sym)], TYPE_SIZE(sym));
  1431.     /* end line if giving full addresses */
  1432.     if (adrflag) printf("\n");
  1433.     zpadr("overloads", (char *) OVERLOADS(sym));
  1434.     zpadr("dcl", (char *) DECLARED(sym));
  1435.     zpsymrefa("alias", ALIAS(sym));
  1436.     if (TYPE_ATTR(sym)) printf(" type_attr %d", TYPE_ATTR(sym));
  1437.     /* list original name if available, putting : in front to mark it */
  1438.     if (ORIG_NAME(sym) != (char *)0)
  1439.         printf(" :%s", ORIG_NAME(sym));
  1440.     printf("\n");
  1441. }
  1442.  
  1443. void zpsymrefa(char *s, Symbol sym)            /*;zpsymrefa*/
  1444. {
  1445.     if (sym == (Symbol) 0) return;
  1446.     printf(" %s", s);
  1447.     zpsymref(sym);
  1448. }
  1449.  
  1450. void zpsyms(int seq, int unit)            /*;zpsyms*/
  1451. {
  1452.     /* symbol dump by sequence and unit number */
  1453.     Symbol sym;
  1454.     sym = zgetsymptr(seq, unit);
  1455.     zpsym(sym);
  1456. }
  1457.  
  1458. void zpdsym()    /*;zpdsym*/
  1459. {
  1460.     zpsym(zsym);
  1461. }
  1462.  
  1463. void zpdcl(Declaredmap dcl) /*;zpdcl*/
  1464. {
  1465.     Fordeclared    div;
  1466.     char    *str;
  1467.     Symbol    sym;
  1468.  
  1469. #ifdef IBM_PC
  1470.     printf("declared map %p\n", dcl);
  1471. #else
  1472.     printf("declared map %ld\n", dcl);
  1473. #endif
  1474.  
  1475.     FORDECLARED(str, sym, dcl, div)
  1476. #ifdef IBM_PC
  1477.         printf("\"%s\" %p %d\n", str, sym, IS_VISIBLE(div));
  1478. #else
  1479.         printf("\"%s\" %ld %d\n", str, sym, IS_VISIBLE(div));
  1480. #endif
  1481.     ENDFORDECLARED(div)
  1482. }
  1483.  
  1484. void zpddcl() /*;zpddcl*/
  1485. {
  1486.     zpdcl(zdcl);
  1487. }
  1488.  
  1489. void zppdcl(Private_declarations pdcl)                /*;zppdcl*/
  1490. {
  1491.     /* print private declarations */
  1492.     Forprivate_decls    fp;
  1493.     Symbol    s1, s2;
  1494.     int        i = 0;
  1495.  
  1496.     printf("private declared map %d\n", (int)pdcl);
  1497.  
  1498.     FORPRIVATE_DECLS(s1, s2, pdcl, fp)
  1499.         printf("priv decl entry %d \n", ++i);
  1500.         zpsym(s1); 
  1501.         zpsym(s2);
  1502.         printf("\n");
  1503.     ENDFORPRIVATE_DECLS(fp)
  1504. }
  1505.  
  1506. void zppsetsym(Set s)/*;zppsetsym*/
  1507. {
  1508.     zpsetsym(s);
  1509. }
  1510.  
  1511. void zptupsym(Tuple t)/*;zptupsym*/
  1512. {
  1513.     /* print tuple of symbols */
  1514.  
  1515.     int        i, n;
  1516.  
  1517.     n = tup_size(t);
  1518.     if (n == 0) return;
  1519.     printf("%d symbols\n", n);
  1520.     for (i = 1; i <= n; i++) {
  1521.         printf("%d\n", i);
  1522.         zpsym((Symbol) t[i]);
  1523.     }
  1524. }
  1525.  
  1526. void zptupnod(Tuple t)/*;zptupnod*/
  1527. {
  1528.     /* print tuple of nodes */
  1529.  
  1530.     int        i, n;
  1531.  
  1532.     n = tup_size(t);
  1533.     if (n == 0) return;
  1534.     printf("%d nodes\n", n);
  1535.     for (i = 1; i <= n; i++) {
  1536.         printf("%d\n", i);
  1537.         zpnod((Node) t[i]);
  1538.     }
  1539. }
  1540.  
  1541. void zpsmap(Symbolmap smap)                    /*;zpsmap */
  1542. {
  1543.     int i, n;
  1544.     Tuple tup;
  1545.     tup = smap->symbolmap_tuple;
  1546.     n = tup_size(tup);
  1547.     printf("%d entries\n", n/2);
  1548.     for (i = 1; i<n; i += 2) {
  1549.         printf("%d:\n", (i/2)+1);
  1550.         zpsym((Symbol) tup[i]);
  1551.         zpsym((Symbol) tup[i+1]);
  1552.     }
  1553. }
  1554.  
  1555. void zpdmap(Nodemap dmap)                    /*;zpdmap */
  1556. {
  1557.     int i, n;
  1558.     Tuple tup;
  1559.  
  1560.     tup = dmap->nodemap_tuple;
  1561.     n = tup_size(tup);
  1562.     printf("%d entries\n", n/2);
  1563.     for (i = 1; i<n; i += 2) {
  1564.         printf("%d:\n", (i/2)+1);
  1565.         zpnod((Node) tup[i]);
  1566.         zpnod((Node) tup[i+1]);
  1567.     }
  1568. }
  1569.  
  1570. void trapn(Node node)                    /*;trapn*/
  1571. {
  1572.     /* called on reference to trapped node */
  1573.     zpnod(node);
  1574. }
  1575.  
  1576. void traps(Symbol sym)                    /*;traps*/
  1577. {
  1578.     /* called on reference to trapped symbol */
  1579.     zpsym(sym);
  1580. }
  1581.  
  1582. void trapini()                    /*;trapini*/
  1583. {
  1584.     FILE    *tfile;
  1585.  
  1586.     trapns = trapnu = trapss = trapsu = 0;
  1587.     tfile = efopen("trapf", "r", "t");
  1588.     if (tfile == (FILE *)0) return;
  1589.     fscanf(tfile, "%d%d%d%d", &trapss, &trapsu, &trapns, &trapnu);
  1590.     if (trapns | trapnu | trapss | trapsu) {
  1591.         printf("trap set ss %d su %d ns %d nu %d\n", trapss, trapsu,
  1592.           trapns, trapnu);
  1593.     }
  1594.     fclose(tfile);
  1595. }
  1596.  
  1597. void trapset(int ns, int nu, int ss, int su)                /*;trapset*/
  1598. {
  1599.     printf("trapset ns %d nu %d ss %d su %d\n", ns, nu, ss, su);
  1600.     trapns = ns; 
  1601.     trapnu = nu; 
  1602.     trapss = ss; 
  1603.     trapsu = su;
  1604. }
  1605.  
  1606. Node zgetnodptr(int seq, int unit)        /*;zgetnodptr*/
  1607. {
  1608.     /* here to convert seq and unit to pointer to symbol.
  1609.      * we require that the symbol has already been allocated
  1610.      * This is variant of getnodptr; however it does not raise chaos
  1611.      * if node not found, but just prints error message
  1612.      */
  1613.  
  1614.     Tuple    nodptr;
  1615.     Node    node;
  1616.  
  1617.     /* TBSL: need to get SEQPTR table for unit, and return address
  1618.      */
  1619.     if (unit == 0) {
  1620.         if (seq == 1) return OPT_NODE;
  1621.         if (seq == 0) return (Node)0;
  1622.         if (seq>0 && seq <= tup_size(init_nodes)) {
  1623.             node = (Node) init_nodes[seq];
  1624.             return node;
  1625.         }
  1626.         else {
  1627.             printf(" zgetnodptr - node s%du%d not found \n", seq, unit);
  1628.             return (Node) 0;
  1629.         }
  1630.     }
  1631.     if (unit <= unit_numbers) {
  1632.         nodptr = (Tuple) pUnits[unit]->treInfo.tableAllocated;
  1633.         if (seq == 0) {
  1634.             printf(" zgetnodptr - node s%du%d not found \n", seq, unit);
  1635.             return (Node) 0;
  1636.         }
  1637.         if (seq <= tup_size(nodptr)) {
  1638.             node = (Node) nodptr[seq];
  1639.             if (node == (Node)0) {/* here to allocate node on first reference */
  1640.                 node = node_new_noseq(as_unread);
  1641.                 N_SEQ(node) = seq;
  1642.                 N_UNIT(node) = unit;
  1643.                 nodptr[seq] = (char *) node;
  1644.             }
  1645.             return node;
  1646.         }
  1647.     }
  1648.     printf(" zgetnodptr - node s%du%d not found \n", seq, unit);
  1649.     return (Node) 0;
  1650. }
  1651.  
  1652. Symbol zgetsymptr(int seq, int unit)        /*;getsymptr*/
  1653. {
  1654.     /* here to convert seq and unit to pointer to symbol.
  1655.      * we require that the symbol has already been allocated
  1656.      * this is variant of getsymptr; it does not raise chaos if
  1657.      * symbol cannot be found, but just prints error message
  1658.      */
  1659.  
  1660.     Tuple    symptr;
  1661.     Symbol    sym;
  1662.     int    items;
  1663.  
  1664.     /* TBSL: need to get SEQPTR table for unit, and return address
  1665.      */
  1666.     if (unit == 0) {
  1667.         if (seq == 0) return (Symbol)0;
  1668.         if (seq>0 && seq <= tup_size(init_symbols)) {
  1669.             sym = (Symbol) init_symbols[seq];
  1670.             return sym;
  1671.         }
  1672.         else {
  1673.             chaos("unit 0 error getsymptr");
  1674.         }
  1675.     }
  1676.     if (unit <= unit_numbers) {
  1677.         struct unit *pUnit = pUnits[unit];
  1678.         symptr = (Tuple) pUnit->aisInfo.symbols;
  1679.         if (symptr == (Tuple)0) {
  1680.             items = pUnit->aisInfo.numberSymbols;
  1681.             symptr = tup_new(items);
  1682.             pUnit->aisInfo.symbols = (char *) symptr;
  1683.         }
  1684.         if (seq <= tup_size(symptr)) {
  1685.             sym = (Symbol) symptr[seq];
  1686.             if (sym == (Symbol)0) {
  1687.                 sym = sym_new_noseq(na_void);
  1688.                 symptr[seq] = (char *) sym;
  1689.                 S_SEQ(sym) = seq;
  1690.                 S_UNIT(sym) = unit;
  1691.             }
  1692.             if (trapss>0 && seq == trapss && unit == trapsu) traps(sym);
  1693.             return sym; /* return newly allocated symbol */
  1694.         }
  1695.         else {
  1696.             printf(" zgetsymptr: symbol not found, return 0\n");
  1697.             return (Symbol) 0;
  1698.         }
  1699.     }
  1700.     printf(" zgetsymptr: symbol not found, return 0\n");
  1701.     return (Symbol) 0;
  1702. }
  1703.  
  1704. void zpsymref(Symbol sym)                /*;zpsymref*/
  1705. {
  1706.     /* print symbol sequence and unit */
  1707.  
  1708.     int    seq, unit;
  1709.  
  1710.     if (sym != (Symbol)0) {
  1711.         seq = S_SEQ(sym);
  1712.         unit = S_UNIT(sym);
  1713.     }
  1714.     else {
  1715.         seq = 0; 
  1716.         unit = 0;
  1717.     }
  1718.     printf(" s%du%d", seq, unit);
  1719. }
  1720.  
  1721. void zpnodref(Node nod)                /*;zpnodref*/
  1722. {
  1723.     /* print node sequence and unit */
  1724.  
  1725.     int    seq, unit;
  1726.  
  1727.     if (nod != (Node)0) {
  1728.         seq = N_SEQ(nod);
  1729.         unit = N_UNIT(nod);
  1730.     }
  1731.     else {
  1732.         seq = 0; 
  1733.         unit = 0;
  1734.     }
  1735.     printf(" n%du%d", seq, unit);
  1736. }
  1737.  
  1738. void zpunit(int unum)                /*;zpunit*/
  1739. {
  1740.     /* print information for nodes and symbols in specified  unit */
  1741.  
  1742.     Tuple stup, ntup, sig;
  1743.     int    nodes, symbols, i, rootseq, j, n;
  1744.     Node    first_node, unit_node, nod;
  1745.     Symbol    sym;
  1746.     struct unit *pUnit;
  1747.  
  1748.     /* disable address printing */
  1749.     adrflag = FALSE;
  1750.     if (unum > 0) {
  1751.         pUnit = pUnits[unum];
  1752.         nodes = pUnit->treInfo.nodeCount;
  1753.         ntup = (Tuple) pUnit->treInfo.tableAllocated;
  1754.         symbols = pUnit->aisInfo.numberSymbols;
  1755.         stup = (Tuple) pUnit->aisInfo.symbols;
  1756.         printf("unit dump for unit %d %s\n", unum, pUnit->name);
  1757.         /* rootseq doesn't seem used - bp */
  1758.         rootseq = 0;
  1759.         first_node = (Node) getnodptr(rootseq, unit_number_now);
  1760.         unit_node = N_AST2(first_node);
  1761.     }
  1762.     else { /* if dumping unit 0 */
  1763.         nodes = seq_node_n;
  1764.         ntup = tup_copy(seq_node);
  1765.         ntup[0] = (char *) seq_node_n;
  1766.         symbols = seq_symbol_n;
  1767.         stup = tup_copy(seq_symbol);
  1768.         stup[0] = (char *) seq_symbol_n;
  1769.         printf("unit dump for unit 0\n");
  1770.     }
  1771.     for (i = 1; i <= symbols; i++) {
  1772.         sym = (Symbol) stup[i];
  1773.         if (sym != (Symbol)0) {
  1774.             zpsym(sym);
  1775.             sig = SIGNATURE(sym);
  1776.             if (sig != (Tuple)0) zpsig(sym);
  1777.         }
  1778.     }
  1779.     for (i = 1; i <= nodes; i++) {
  1780.         nod = (Node) ntup[i];
  1781.         if (nod != (Node)0) {
  1782.             zpnod(nod);
  1783.             sig = N_LIST(nod);
  1784.             if (sig != (Tuple)0) { /* print N_LIST if present */
  1785.                 n = tup_size(sig);
  1786.                 printf(" n_list %d ", tup_size(sig));
  1787.                 for (j = 1; j <= n; j++)
  1788.                     zpnodref((Node) sig[j]);
  1789.                 printf("\n");
  1790.             }
  1791.         }
  1792.     }
  1793.     if (unum == 0) { /* free node and symbol tuples for unit 0 */
  1794.         tup_free(stup);
  1795.         tup_free(ntup);
  1796.     }
  1797.     adrflag = TRUE; /* restore address print flag */
  1798. }
  1799.  
  1800. void zpint(int n)            /*;zpint*/
  1801. {
  1802.     /* print n at int */
  1803.     char ch;
  1804.  
  1805.     ch = (char) n;
  1806.     ch = isascii(ch) && isprint(ch) ? ch : ' ';
  1807.     printf(" %d %u %x %c  :duxc\n", n, n, n, ch);
  1808. }
  1809. #endif
  1810.